perm filename COMPLR.NEW[CMP,LSP]3 blob
sn#335140 filedate 1978-02-12 generic text, type T, neo UTF8
00100 (PROG (SEXPR IBASE)
00200 (SETQ IBASE (ADD1 7))
00300 LOOP (SETQ SEXPR (ERRSET (READ)))
00400 (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
00500 (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
00600 (GO LOOP)))
00700 (PRINT (EVAL (CAR SEXPR)))
00800 (GO LOOP))
00900
01000 (BEGINBLOCK COMPILER)
01100
01200 (DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME UPPERFLAG)
01300 (SPECIAL CURBIND INPROG P1SCNT FOUNDFREE)
01400 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
01500 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
01600 (SPECIAL LDLST PRGSPFLG PROGVARS CCLST RSL CTAG VARLIST)
01700 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
01800 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
01900 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
02000 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
02100 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
02200 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
02300 (SPECIAL IBASE BASE *NOPOINT INUM0)
02400 (SPECIAL TRACELIST SHOWNAMES))
02500
02600 (DECLARE (DEFPROP CMP T *FSUBR)
02700 (DEFPROP COMPERR T *FSUBR)
02800 (DEFPROP COMPILE T *FSUBR)
02900 (DEFPROP COMPL T *FSUBR)
03000 (DEFPROP DECLARE T *FSUBR)
03100 (DEFPROP NEXTSYM T *FSUBR)
03200 (DEFPROP PROGN T *LSUBR)
03300 (DEFPROP SPECIAL T *FSUBR)
03400 (DEFPROP STARTSYM T *FSUBR)
03500 (DEFPROP STOPSYM T *FSUBR)
03600 (DEFPROP UNSPECIAL T *FSUBR)
03700 (DEFPROP USERERR T *FSUBR))
03800
03900 (BEGINBLOCK MACROS)
04000
04100 (DEFPROP DFUNC
04200 (LAMBDA (L)
04300 (LIST (Q DEFPROP)
04400 (CAADR L)
04500 (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
04600 (Q EXPR)))
04700 MACRO)
04800
04900 (DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
05000
05100 (DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
05200
05300
00100 (DEFPROP IFIF
00200 (LAMBDA (L)
00300 (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
00400 MACRO)
00500
00600 (DEFPROP INCR
00700 (LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
00800 MACRO)
00900
01000 (DEFPROP MAPDEF
01100 (LAMBDA (L)
01200 (LIST (Q MAPCAR)
01300 (SUBST (CADR L)
01400 (Q IND)
01500 (Q (FUNCTION (LAMBDA (PAIR)
01600 (PUTPROP (CAR PAIR)
01700 (CADR PAIR)
01800 (QUOTE IND))))))
01900 (LIST (Q QUOTE) (CDDR L))))
02000 MACRO)
02100
02200 (DEFPROP MCONS
02300 (LAMBDA (L)
02400 (COND ((NULL (CDDR L)) (CADR L))
02500 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
02600 MACRO)
02700
02800 (DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
02900
03000 (DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
03100
03200 (DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
03300
03400 (DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)
03500
03600 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
03700
03800 (DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
03900
04000 (DEFPROP USERWARN
04100 (LAMBDA (L)
04200 (LIST (Q PRINTMSG)
04300 (LIST (Q APPEND)
04400 (LIST (Q LIST) (CADR L))
04500 (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
04600 (Q (LIST (CURFUN))))))
04700 MACRO)
04800
04900 (BEGINBLOCK PROPTABLE)
05000
05100 (DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
05200
05300
00100 (DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
00200
00300 (DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
00400
00500 (DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
00600
00700 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
00800
00900 (DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
01000
01100 (DFUNC (DELETEPROP IDENT PROPNAM)
01200 (PROG (TEM)
01300 (SETQ TEM IDENT)
01400 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
01500 (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
01600 (RETURN T)))
01700 (SETQ TEM (CDDR TEM))
01800 (GO LOOP)))
01900
02000 (DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
02100
02200 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
02300 (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
02400
02500 (DFUNC (SEEKPROP IDENT PROPNAM)
02600 (PROG (TEM)
02700 (SETQ TEM (GETL IDENT (LIST PROPNAM)))
02800 (COND ((NULL TEM) (RETURN NIL)))
02900 (RETURN TEM)))
03000
03100 (DFUNC (SETPROP IDENT PROPNAM PROPVAL)
03200 (PUTPROP IDENT PROPVAL PROPNAM))
03300
03400 (ENDBLOCK PROPTABLE)
03500
03600 (ENDBLOCK MACROS)
03700
03800 (BEGINBLOCK TOPLEVEL)
03900
04000 (DFUNC (ACTONEXPR XPR)
04100 (PROG (ACTION)
04200 (COND ((ATOM XPR) (GO FLUSH)))
04300 (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
04400 (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
04500 FLUSH(FLUSHEXPR XPR)
04600 (RETURN NIL)))
04700
04800 (DFUNC (ACTONMACRO XPR)
04900 (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
05000
05100
00100 (DEFPROP CMP
00200 (LAMBDA (L)
00300 (COND ((NULL L) NIL)
00400 ((NULL (CDR L)) (COMPILEFUN (CAR L)))
00500 (T (PUTPROP (CAAR L)
00600 (MCONS (Q LAMBDA) (CDAR L) (CDR L))
00700 (COND ((NULL (CDDR L)) (Q EXPR)) (T (CADDR L))))
00800 (COMPILEFUN (CAAR L)))))
00900 FEXPR)
01000
01100 (DFUNC (COMPDEF DEFIN)
01200 (PROG (ACTION)
01300 (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
01400 (USERERR ARGNOERR-COMPDEF)))
01500 (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
01600 ((PROPVAL ACTION) DEFIN)
01700 (RETURN NIL)))
01800 (FLUSHDEF DEFIN)
01900 (RETURN NIL)))
02000
02100 (DFUNC (COMPFILE INFILE OUTFILE)
02200 (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
02300 (INITPROP (Q CURFILE) (Q NAME) INFILE)
02400 (SETQ STARTTIME (TIME))
02500 (SETQ CODESIZE (SETQ CONSTSIZE 0))
02600 (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
02700 (TELLTALE (CADR INFILE) STARTTIME)
02800 (DELETEPROP (Q CURFILE) (Q NAME))))
02900
03000 (DFUNC (COMPFUNC NAME EXPR FLAG)
03100 (PROG (LOCVARS SPECVARS P1CNT P2CNT LASTOUT)
03200 (STARTSYM VAL VAR TAG)
03300 (INITPROP (Q CURFUN) (Q NAME) NAME)
03400 (PASS2 NAME (PASS1 NAME EXPR FLAG) FLAG)
03500 (DELETEPROP (Q CURFUN) (Q NAME))
03600 (STOPSYM VAL VAR TAG)
03700 (COND ((NOT (EQUAL P2CNT P1CNT))
03800 (PRINTMSG (LIST P1CNT P2CNT))
03900 (COMPERR COUNTSDISAGREE-COMPFUNC)))
04000 (RETURN NAME)))
04100
04200 (DEFPROP COMPILE
04300 (LAMBDA (NAMES)
04400 (PROG (DONE)
04500 LOOP (COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
04600 (COND ((NOT (ATOM (CAR NAMES)))
04700 (OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
04800 (T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
04900 (SETQ NAMES (CDR NAMES))
05000 (GO LOOP)))
05100 FEXPR)
05200
05300
00100 (DFUNC (COMPILEFUN NAME)
00200 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
00300 DONE PLIST)
00400 (SETQ CODESIZE (SETQ CONSTSIZE 0))
00500 (SETQ PLIST (CDR NAME))
00600 LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
00700 (SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
00800 (COND ((NULL PROP) (GO ELOOP)))
00900 (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
01000 ((PROPVAL PROP)
01100 (LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
01200 ELOOP(SETQ PLIST (CDDR PLIST))
01300 (GO LOOP)))
01400
01500 (DEFPROP COMPL
01600 (LAMBDA (FILES)
01700 (PROG (MSGCHAN)
01800 (COND ((NOT (NULL LISTING))
01900 (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
02000 (GENSYM)
02100 LISTING)))))
02200 LOOP (COND ((NULL FILES) (OUTC MSGCHAN NIL)
02300 (OUTC NIL T)
02400 (RETURN NIL)))
02500 (COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
02600 (AND (NOT (ATOM (CAR FILES)))
02700 (NOT (ATOM (CDAR FILES)))))
02800 (SETQ INDEV (CAR FILES))
02900 (GO ELOOP)))
03000 (COMPFILE (LIST INDEV (CAR FILES))
03100 (LIST OUTDEV
03200 (CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
03300 (T (CAAR FILES)))
03400 OUTEXT)))
03500 ELOOP(SETQ FILES (CDR FILES))
03600 (GO LOOP)))
03700 FEXPR)
03800
03900 (DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
04000
04100 (DFUNC (CURFILE) (GETPROP (Q CURFILE) (Q NAME)))
04200
04300 (DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))
04400
04500 (DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)
04600
04700
00100 (DFUNC (DEFEXPR DEF)
00200 (PROG (FN EX)
00300 (SETQ FN (CADR DEF))
00400 (SETQ EX (CADDR DEF))
00500 (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
00600 (FLUSHDEF DEF))
00700 ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
00800 (COND ((REMPROP FN (Q *UNDEF))
00900 (PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
01000 (PUTPROP FN T (Q *LSUBR))
01100 (COMPFUNC FN
01200 (MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
01300 (Q LSUBR)))
01400 (T (REMPROP FN (Q *UNDEF))
01500 (PUTPROP FN T (Q *SUBR))
01600 (COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))
01700 (TYPEFN FN)))
01800
01900 (DFUNC (DEFFEXPR DEF)
02000 (PROG (FN EX)
02100 (SETQ FN (CADR DEF))
02200 (SETQ EX (CADDR DEF))
02300 (COND ((REMPROP FN (Q *UNDEF))
02400 (PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
02500 (PUTPROP FN T (Q *FSUBR))
02600 (COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))
02700 (TYPEFN FN)))
02800
02900 (DFUNC (DEFMACRO DEF)
03000 (PROGN (COND ((REMPROP (CADR DEF) (Q *UNDEF))
03100 (PRINTMSG (CONS (CADR DEF)
03200 (Q (MACRO USED AS SUBR))))))
03300 (PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
03400 (TYPEFN (CADR DEF))))
03500
03600 (DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
03700
03800 (DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
03900
04000 (DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
04100
04200
04300 (DFUNC (DODF L) (COMPDEF (MAKDEF (CDR L) (Q FEXPR))))
04400
04500 (DFUNC (DODM L) (COMPDEF (MAKDEF (CDR L) (Q MACRO))))
04600
00100 (DFUNC (DOFILE DOREADS INFILE OUTFILE)
00200 (PROG (LINCNT)
00300 (SETQ LINCNT 0)
00400 (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
00500 (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
00600 (INC (Q INCHAN) NIL)
00700 (OUTC (Q OUTCHAN) NIL)
00800 (DOREADS)
00900 (OUTC NIL T)
01000 (INC NIL T)))
01100
01200 (DFUNC (FLUSHEXPR EXPR)
01300 (PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))
01400
01500 (DFUNC (FLUSHLAP ENTRY)
01600 (PROG (NAME FLAG TYPE STAT)
01700 (SETQ NAME (CADR ENTRY))
01800 (SETQ FLAG (CADDR ENTRY))
01900 (SETQ TYPE (ASSOC FLAG
02000 (Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
02100 (SUBR *SUBR)))))
02200 (COND ((NULL TYPE) (GO PRINT)))
02300 (SETQ TYPE (CADR TYPE))
02400 (COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
02500 (GETPROP NAME (Q *UNDEF)))
02600 (PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
02700 (SETPROP NAME TYPE T)
02800 (REMPROP NAME (Q *UNDEF))
02900 (TYPEFN NAME)
03000 PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
03100 (OUTPUTSTAT ENTRY)
03200 LOOP (SETQ STAT (ERRSET (READ)))
03300 (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
03400 (OUTPUTSTAT (CAR STAT))
03500 (COND ((NULL (CAR STAT)) (RETURN NIL)))
03600 (GO LOOP)))
03700
03800 (DFUNC (MAKDEFIN NAME ARGS BODY TYPE)
03900 (LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))
04000
04100 (DFUNC (MAKDEF ARGS TYPE)
04200 (COND ((ATOM (CAR ARGS))
04300 (MAKDEFIN (CAR ARGS)
04400 (CADR ARGS)
04500 (CADDR ARGS)
04600 (COND ((NULL (CDDDR ARGS)) TYPE) (T (CADDDR ARGS)))))
04700 (T (MAKDEFIN (CAAR ARGS)
04800 (CDAR ARGS)
04900 (CADR ARGS)
05000 (COND ((NULL (CDDR ARGS)) TYPE) (T (CADDR ARGS)))))))
05100
05200 (DFUNC (MAPPUT EXP)
05300 (PROG (IND ARGS)
05400 (SETQ IND (CAR EXP))
05500 (SETQ ARGS (CDR EXP))
05600 LOOP (COND ((NULL ARGS) (RETURN EXP)))
05700 (PUTPROP (CAR ARGS) T IND)
05800 (SETQ ARGS (CDR ARGS))
05900 (GO LOOP)))
06000
06100
00100 (DFUNC (PRINTMSG MESSAGE)
00200 (PROG (CHAN LINCNT)
00300 (SETQ CHAN (OUTC MSGCHAN NIL))
00400 (SETQ LINCNT 0)
00500 (COND ((NOT (ATMARGIN)) (LINEF 2)))
00600 (PRINL (CONS (Q *) MESSAGE))
00700 (LINEF 1)
00800 (OUTC CHAN NIL)))
00900
01000 (DFUNC (READLOOP ACTFUN)
01100 (PROG (EXPR)
01200 LOOP (SETQ EXPR (ERRSET (READ)))
01300 (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
01400 (ACTFUN (CAR EXPR))
01500 (GO LOOP)))
01600
01700 (DEFPROP SPECIAL
01800 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
01900 FEXPR)
02000
02100 (DFUNC (TELLTALE FILENAME STARTTIME)
02200 (PROG (CHAN UNDS)
02300 (SETQ CHAN (OUTC MSGCHAN NIL))
02400 (CARRETN)
02500 (LINEF 1)
02600 (PRINL (LIST FILENAME (Q COMPILED)))
02700 (PRINL (LIST CODESIZE (Q WORDS)))
02800 (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
02900 (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
03000 1750))
03100 (Q SECONDS)))
03200 (LINEF 2)
03300 UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
03400 (COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
03500 (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
03600 (SETQ UNDFUNS (CDR UNDFUNS))
03700 (GO UNDF)
03800 UNDF1(COND ((NULL UNDS) (GO GENF)))
03900 (PRINL (Q (UNDEFINED FUNCTIONS)))
04000 (LINEF 1)
04100 (PRINL UNDS)
04200 (LINEF 2)
04300 GENF (COND ((NULL GENFUNS) (GO END)))
04400 (PRINL (Q (GENERATED FUNCTIONS)))
04500 (LINEF 1)
04600 (PRINL GENFUNS)
04700 (LINEF 2)
04800 END (OUTC CHAN NIL)))
04900
05000
00100 (DFUNC (TYPEFN MESSAGE)
00200 (PROG (CHAN LINCNT)
00300 (COND ((NULL SHOWNAMES) (RETURN NIL)))
00400 (SETQ CHAN (OUTC MSGCHAN NIL))
00500 (SETQ LINCNT 0)
00600 (COND ((ATMARGIN) (LINEF 1)))
00700 (PRINS MESSAGE)
00800 (OUTC CHAN NIL)))
00900
01000 (DEFPROP UNSPECIAL
01100 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
01200 FEXPR)
01300
01400 (BEGINBLOCK INITIALIZATION)
01500
01600 (DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (Q CSTART))))
01700
01800 (DFUNC (CSTART)
01900 (PROGN (INITFN NIL)
02000 (COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
02100 (SYSIN (COMPLR . INI))))
02200 (COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
02300 (SYSIN DSK: (COMPLR . INI))))
02400 (LINEF 1)
02500 (PRINL (Q (LISP COMPILER)))))
02600
02700 (ENDBLOCK INITIALIZATION)
02800
02900 (MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
03000
03100 (MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
03200 (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
03300 (UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
03400 (*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))
03500
03600 (MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
03700 (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
03800 (*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
03900 (*LSUBR EVAL))
04000
04100 (SETQ LISTING NIL)
04200
04300 (SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
04400
04500 (SETQ OUTEXT (QUOTE LAP))
04600
04700 (SETQ SHOWNAMES T)
04800
04900 (ENDBLOCK TOPLEVEL)
05000
05100 (BEGINBLOCK PASS1)
05200
05300
00100 (DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
00200
00300 (DFUNC (GENFUN EXPR)
00400 (PROG (NAME ARGS CALL)
00500 (COND ((ATOM EXPR) (RETURN EXPR)))
00600 (COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
00700 (COMPERR NOTLAMBDA-GENFUN)))
00800 (SETQ ARGS (CADR EXPR))
00900 (SETQ CALL (CADDR EXPR))
01000 (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
01100 (RETURN (CAR CALL))))
01200 (SETQ NAME (MAKESYM (NEXTSYM SUBFUN) (CURFUN)))
01300 (SETQ GENFUNS (CONS NAME GENFUNS))
01400 (RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))
01500
01600 (DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
01700
01800 (DFUNC (P1 XPR)
01900 (PROG (TEM)
02000 (COND ((ATOM XPR) (GO ATOM)))
02100 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
02200 (COND ((EQ (CAAR XPR) (Q LAMBDA))
02300 (RETURN (PASS1LAMBDA XPR CURBIND))))
02400 (COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
02500 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
02600 ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
02700 (COND ((SETQ TEM (ASSOC XPR CURBIND)) (SETQ XPR (CDR TEM))))
02800 (INCR P1CNT)
02900 (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
03000 (RETURN XPR)))
03100 (COND ((VARB XPR) (RETURN XPR)))
03200 (RPLACD (ASSOC XPR LOCVARS) P1CNT)
03300 (RETURN XPR)
03400 ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
03500 (COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
03600 (RETURN ((PROPVAL TEM) XPR))))
03700 (COND ((SETQ TEM (ASSOC (CAR XPR) CURBIND))
03800 (SETQ XPR (CONS (CDR TEM) (CDR XPR)))))
03900 (COND ((OR (SPECIALP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
04000 (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
04100 (RETURN (P1ELSE XPR))))
04200
04300 (DFUNC (P1ANDOR XPR)
04400 (PROG (TEM CT ARGS)
04500 (SETQ TEM LOCVARS)
04600 (SETQ CT P1CNT)
04700 (SETQ ARGS (MAPP1 (CDR XPR)))
04800 (INCR P1CNT)
04900 (P1BUG CT P1CNT TEM)
05000 (RETURN (CONS (CAR XPR) ARGS))))
05100
05200
00100 (DFUNC (P1BIND VARS)
00200 (PROG (VAR NEWVARS)
00300 (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
00400 LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
00500 (SETQ VAR (CAR VARS))
00600 (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
00700 (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
00800 (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
00900 (GO ELOOP)))
01000 (SETQ CURBIND (CONS (CONS VAR
01100 (SETQ VAR (COND ((ASSOC VAR LOCVARS)
01200 (NEXTSYM VAR))
01300 (T VAR))))
01400 CURBIND))
01500 (SETQ LOCVARS (CONS (CONS VAR 0) LOCVARS))
01600 ELOOP(SETQ NEWVARS (CONS VAR NEWVARS))
01700 (SETQ VARS (CDR VARS))
01800 (GO LOOP)))
01900
02000 (DFUNC (P1BUG LOW HIGH PTR)
02100 (PROG (X)
02200 LOOP (COND ((NULL PTR) (RETURN NIL)))
02300 (SETQ X (CAR PTR))
02400 (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
02500 (SETQ PTR (CDR PTR))
02600 (GO LOOP)))
02700
02800 (DFUNC (P1COND XPR)
02900 (PROG (TEM CT PAIRS)
03000 (SETQ TEM LOCVARS)
03100 (SETQ CT P1CNT)
03200 (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
03300 (INCR P1CNT)
03400 (P1BUG CT P1CNT TEM)
03500 (INCR P1CNT)
03600 (RETURN (CONS (CAR XPR) PAIRS))))
03700
03800 (DFUNC (P1CONS XPR)
03900 (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
04000 ((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
04100 (T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
04200
04300 (DFUNC (P1ELSE XPR)
04400 (PROGN (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
04500 (PUTPROP (CAR XPR) T (Q *UNDEF))
04600 (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))))
04700
04800
00100 (DFUNC (P1ERRSET XPR)
00200 (COND ((ATOM (CADR XPR)) XPR)
00300 (T (MCONS (CAR XPR)
00400 (LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
00500 (CDDR XPR)))))
00600
00700 (DFUNC (P1EVAL XPR)
00800 (PROG (CDRXPR)
00900 (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
01000 (COND ((NOT (NULL (CDR CDRXPR)))
01100 (RETURN (CONS (Q EVAL) CDRXPR))))
01200 (RETURN (CONS (Q *EVAL) CDRXPR))))
01300
01400 (DFUNC (P1FUNCTION XPR) (LIST (Q QUOTE) (GENFUN (CADR XPR))))
01500
01600 (DFUNC (P1*FUNCTION XPR) (LIST (Q *FUNCTION) (GENFUN (CADR XPR))))
01700
01800 (DFUNC (P1GO XPR)
01900 (PROGN (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
02000 (COND ((ATOM (CADR XPR)) XPR)
02100 (T (LIST (CAR XPR) (P1 (CADR XPR)))))))
02200
02300 (DFUNC (P1LABEL XPR)
02400 (PROG (FN)
02500 (INITPROP (CADAR XPR) (Q FUNVAR) T)
02600 (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
02700 (DELETEPROP (CADAR XPR) (Q FUNVAR))
02800 (RETURN (P1 (LIST (Q PROG)
02900 (LIST (CADAR XPR))
03000 (LIST (Q SETQ) (CADAR XPR) FN)
03100 (LIST (Q RETURN)
03200 (CONS (CADAR XPR) (CDR XPR))))))))
03300
03400
00100 (DFUNC (P1PROG X)
00200 ((LAMBDA (CURBIND)
00300 (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
00400 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
00500 (SETQ INPROG T)
00600 (SETQ X (CDR X))
00700 (SETQ P1LL (P1BIND (CAR X)))
00800 (SETQ TEM LOCVARS)
00900 (SETQ P1SCNT (INCR P1CNT))
01000 LOOP1(SETQ X (CDR X))
01100 (COND ((NULL X) (GO END1)))
01200 (INCR P1CNT)
01300 (COND ((ATOM (CAR X))
01400 (COND ((ASSOC (CAR X) TAGLIST)
01500 (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
01600 (SETQ TAGLIST (CONS (CONS (CAR X) (NEXTSYM TAG))
01700 TAGLIST))
01800 (SETQ PR (CONS (CAR X) PR)))
01900 (T (SETQ PR (CONS (P1 (CAR X)) PR))))
02000 (GO LOOP1)
02100 END1 (INCR P1CNT)
02200 (P1BUG P1SCNT P1CNT TEM)
02300 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
02400 LOOP (COND ((NULL (CDR TEM)) (GO END)))
02500 (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
02600 (USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
02700 (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
02800 (MAKESPECIAL (CAADR TEM))))
02900 ELOOP(SETQ TEM (CDR TEM))
03000 (GO LOOP)
03100 END (INCR P1CNT)
03200 (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
03300 CURBIND))
03400
03500 (DFUNC (P1RETURN XPR)
03600 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
03700 (T (LIST (Q RETURN)
03800 (P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
03900
04000 (DFUNC (P1SETQ XPR)
04100 (PROG (VAR TEM VAL)
04200 (COND ((NOT (VARIABLEP (CAR XPR)))
04300 (USERERR NOTVARIABLE-P1SETQ)))
04400 (SETQ VAR (COND ((SETQ TEM (ASSOC (CADR XPR) CURBIND))
04500 (CDR TEM))
04600 (T (CADR XPR))))
04700 (VARB VAR)
04800 (SETQ VAL (P1 (CADDR XPR)))
04900 (INCR P1CNT)
05000 (INCR P1CNT)
05100 (RETURN (LIST (Q SETQ) VAR VAL))))
05200
05300
00100 (DFUNC (P1STORE XPR)
00200 (PROG (ARG1 ARG2)
00300 (SETQ ARG2 (P1 (CADDR XPR)))
00400 (SETQ ARG1 (P1 (CADR XPR)))
00500 (RETURN (LIST (CAR XPR) ARG1 ARG2))))
00600
00700 (DFUNC (P1SUBRARGS ARGS)
00800 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
00900 (T (MAPP1 ARGS))))
01000
01100 (DFUNC (PASS1 NAME EXPR FLAG)
01200 (PROG (LL CURBIND P1SCNT INPROG FOUNDFREE LOCVS)
01300 (SETQ INPROG NIL)
01400 (SETQ P1CNT 1)
01500 (SETQ LOCVARS (SETQ SPECVARS NIL))
01600 (SETQ LL (P1BIND (CADR EXPR)))
01700 (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
01800 (STARTSYM SUBFUN)
01900 (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
02000 (STOPSYM SUBFUN)
02100 (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
02200 UNDECLARED
02300 FREE
02400 VARIABLES)))
02500 (SETQ LOCVS LOCVARS)
02600 (SETQ LOCVARS NIL)
02700 LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
02800 (COND ((NOT (SPECIALP (CAAR LOCVS)))
02900 (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
03000 (SETPROP (CAAR LOCVS) (Q LOCAL) T))
03100 (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
03200 (SETQ LOCVS (CDR LOCVS))
03300 (GO LOOP)))
03400
03500 (DFUNC (PASS1FSUBR XPR) XPR)
03600
03700 (DFUNC (PASS1FUNVAR XPR)
03800 (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
03900
04000 (DFUNC (PASS1LAMBDA XPR CURBIND)
04100 (PROG (ARGS VARS BODY)
04200 (SETQ ARGS (P1SUBRARGS (CDR XPR)))
04300 (INCR P1CNT)
04400 (SETQ VARS (P1BIND (CADAR XPR)))
04500 (COND ((NOT (EQUAL (LENGTH ARGS) (LENGTH VARS)))
04600 (USERERR ARGNOERR-P1LAM)))
04700 (SETQ BODY (P1 (CADDAR XPR)))
04800 (INCR P1CNT)
04900 (RETURN (CONS (LIST (Q LAMBDA) VARS BODY) ARGS))))
05000
05100 (DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
05200
05300
00100 (DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
00200
00300 (DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
00400
00500 (DFUNC (PASS1UNDEF XPR)
00600 (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
00700 (PASS1SUBR XPR)))
00800
00900 (DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
01000
01100 (DFUNC (VARB X)
01200 (PROG NIL
01300 (COND ((ASSOCR X CURBIND) (RETURN NIL))
01400 ((SPECIALP X) (GO SPEC)))
01500 (SETQ FOUNDFREE (CONS X FOUNDFREE))
01600 (MAKESPECIAL X)
01700 SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
01800 (RETURN T)))
01900
02000 (DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
02100
02200 (MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
02300 (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
02400 (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
02500 (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
02600 (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
02700 (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
02800
02900 (MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
03000 (ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
03100 (AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
03200 (*FUNCTION P1*FUNCTION) (FUNCTION P1FUNCTION)
03300 (RETURN P1RETURN))
03400
03500 (BEGINBLOCK INTERNALMACROS)
03600
03700 (DEFPROP INMACRO PASS1INMACRO PASS1)
03800
03900 (DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))
04000
04100 (DEFPROP INMACRO
04200 (LAMBDA (DF)
04300 (COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
04400 DEFACTION)
04500
04600 (DEFPROP APPEND
04700 (LAMBDA (L)
04800 (COND ((NULL (CDR L)) NIL)
04900 ((NULL (CDDR L)) (CADR L))
05000 (T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
05100 INMACRO)
05200
05300
00100 (DEFPROP LIST
00200 (LAMBDA (L)
00300 (COND ((NULL (CDR L)) NIL)
00400 ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
00500 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
00600 INMACRO)
00700
00800 (DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)
00900
01000 (DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)
01100
01200 (ENDBLOCK INTERNALMACROS)
01300
01400 (ENDBLOCK PASS1)
01500
01600 (BEGINBLOCK PASS2)
01700
01800 (DFUNC (ACEFFECTS FN)
01900 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))
02000
02100 (DFUNC (ACNUMP X)
02200 (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
02300
02400 (DFUNC (BINDARGS ARGS)
02500 (PROG (ACNUM)
02600 (SETQ ACNUM 1)
02700 LOOP (COND ((NULL ARGS) (RETURN NIL)))
02800 (SETSLOT ACNUM (LIST (CAR ARGS)))
02900 (SETQ ACNUM (ADD1 ACNUM))
03000 (SETQ ARGS (CDR ARGS))
03100 (GO LOOP)))
03200
03300 (DFUNC (BOOLAND EXP VALAC TEST)
03400 (PROG2 (BOOLARGS (CDR EXP) (CAR TEST) (CDR TEST) T) (INCR P2CNT)))
03500
03600 (DFUNC (BOOLARGS ARGS FLAG TAG SWITCH)
03700 (PROG (G)
03800 (CLRLOCS)
03900 (CLEAR1)
04000 (RST TAG)
04100 (PUTPROP (SETQ G (NEXTSYM TAG)) (TOPCOPY PDL) (Q LEVEL))
04200 A (COND ((NULL ARGS) (COND (FLAG (OUTJRST TAG))) (GO C)))
04300 (COND ((AND FLAG (NULL (CDR ARGS))) (GO B)))
04400 (COMPPRED (CAR ARGS)
04500 (CONS (NOT SWITCH) (COND (FLAG G) (T TAG))))
04600 (SETQ ARGS (CDR ARGS))
04700 (GO A)
04800 B (COMPPRED (CAR ARGS) (CONS SWITCH TAG))
04900 (OUTENDTAG G)
05000 C (CLEARBOTH)
05100 (CLEARACS)))
05200
05300
00100 (DFUNC (BOOLEQ EXP VALAC TEST)
00200 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM TAG F)
00300 (SETQ EXP (CDR EXP))
00400 (COND ((AND (NULL VALAC) (NULL TEST)) (COMPSTAT (CADR EXP))
00500 (COMPSTAT (CADDR EXP))
00600 (RETURN NIL)))
00700 (COND ((OR (NOT (NULL VALAC)) (NULL TEST)) (SETQ F NIL)
00800 (SETQ TAG NIL))
00900 (T (SETQ F (CAR TEST)) (SETQ TAG (CDR TEST))))
01000 (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ)))
01100 (SETQ ARG1 (COMPEXPR (CAR EXP) (FREEAC)))
01200 (SETQ ARG2 (COMPEXPR (CADR EXP) (FREEAC)))
01300 (SETQ LOC2 (LOC ARG2))
01400 (SETQ LOC1 (LOC ARG1))
01500 (RST TAG)
01600 (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
01700 ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
01800 (T (LOADARG (SETQ AC (FREEAC)) ARG1)
01900 (SETQ MEM (LOC ARG2))))
02000 (REMOVE ARG1)
02100 (REMOVE ARG2)
02200 (SAVEACS)
02300 (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)
02400 (COND ((NOT (NULL VALAC)) (SETQ AC (BOOLVALUE VALAC TAG))))
02500 (COND ((NOT (NULL TEST)) (OUTJRST (CDR TEST))))
02600 (RETURN AC)))
02700
02800 (DFUNC (BOOLEXPR XPR VALAC TEST)
02900 ((GETPROP (CAR XPR) (Q P2BOOL)) XPR VALAC TEST))
03000
03100 (DFUNC (BOOLNULL EXP VALAC TEST)
03200 (COMPPRED (CADR EXP) (CONS (NOT (CAR TEST)) (CDR TEST))))
03300
03400 (DFUNC (BOOLOR EXP VALAC TEST)
03500 (PROG2 (BOOLARGS (CDR EXP) (NOT (CAR TEST)) (CDR TEST) NIL)
03600 (INCR P2CNT)))
03700
03800 (DFUNC (BOOLVALUE AC TAG)
03900 (PROGN (OUT1 (Q TDZA) AC AC)
04000 (OUTENDTAG TAG)
04100 (OUT1 (Q MOVEI) AC (Q (QUOTU T)))
04200 (MARKVAL AC AC)))
04300
04400
00100 (DFUNC (CALLFSUBR XPR VALAC TEST)
00200 (PROG (FUN ARGS VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (CLEARBOTH)
00600 (LOADARG FARGAC (CONS ARGS (Q QT)))
00700 (PROTECTACS FUN)
00800 (SETQ VAL (MARKVAL VALAC VALUEAC))
00900 (OUTCALL 17 FUN)
01000 (RETURN (TESTJUMP VAL TEST))))
01100
01200 (DFUNC (CALLFUNARGS XPR VALAC TEST)
01300 (PROG (FUN ARGS FUNARGS LOCS VAL)
01400 (SETQ FUN (CAR XPR))
01500 (SETQ ARGS (CDR XPR))
01600 (SETQ FUNARGS (COMPEXPR FUN VALUEAC))
01700 (SETQ LOCS (COMPARGS ARGS))
01800 (CLRCCLST LOCS NIL)
01900 (LOADSUBRARGS LOCS)
02000 (CLEARBOTH)
02100 (CLEARACS)
02200 (SETQ VAL (MARKVAL VALAC VALUEAC))
02300 (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
02400 (REMOVE FUNARGS)
02500 (RETURN (TESTJUMP VAL TEST))))
02600
02700
00100 (DFUNC (CALLLSUBR XPR VALAC TEST)
00200 (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (CLEAR1)
00600 (SETQ NARGS (LENGTH ARGS))
00700 (SLOTPUSH (Q (NIL . TAKEN)))
00800 (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (NEXTSYM TAG)) 0 0))
00900 LOOP (COND ((NULL ARGS) (GO CALL)))
01000 (SETQ HOME (TOPCOPY PDL))
01100 (SETQ INST (COMPEXPR (CAR ARGS) VALUEAC))
01200 (RESTORE HOME)
01300 (SETQ TEM (LOC INST))
01400 (SLOTPUSH (Q (NIL . TAKEN)))
01500 (OUTPUSH TEM)
01600 (REMOVE INST)
01700 (SETQ ARGS (CDR ARGS))
01800 (GO LOOP)
01900 CALL (SETQ TEM (PDLDEPTH))
02000 (SAVEACS)
02100 (COND ((NOT (EQ (PDLDEPTH) TEM))
02200 (COMPERR PDLTOOLONG-LSUBRCALL)))
02300 (OUTINST (LIST (Q MOVNI) 6 NARGS))
02400 LLOOP(SLOTPOP)
02500 (COND ((ZEROP NARGS) (GO CALL1)))
02600 (SETQ NARGS (SUB1 NARGS))
02700 (GO LLOOP)
02800 CALL1(CLEARBOTH)
02900 (CLEARACS)
03000 (SETQ VAL (MARKVAL VALAC VALUEAC))
03100 (OUTJCALL 16 FUN)
03200 (OUTTAG RETTAG)
03300 (RETURN (TESTJUMP VAL TEST))))
03400
03500
00100 (DFUNC (CALLSUBR XPR VALAC TEST)
00200 (PROG (FUN ARGS NARGS LOCS TEM VAL)
00300 (SETQ FUN (CAR XPR))
00400 (SETQ ARGS (CDR XPR))
00500 (SETQ LOCS (COMPARGS ARGS))
00600 (SETQ NARGS (LENGTH LOCS))
00700 (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
00800 (EQ NARGS 2)
00900 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
01000 (SETQ LOCS (REVERSE LOCS))
01100 (SETQ FUN (PROPVAL TEM))))
01200 (SETQ TEM (SIDEEFFECTS FUN))
01300 (COND (TEM (CLRCCLST LOCS NIL)))
01400 (LOADSUBRARGS LOCS)
01500 (COND (TEM (CLEARBOTH)))
01600 (PROTECTACS FUN)
01700 (SETQ VAL (MARKVAL VALAC VALUEAC))
01800 (OUTCALL NARGS FUN)
01900 (RETURN (TESTJUMP VAL TEST))))
02000
02100 (DFUNC (CLEAR1) (PROGN (CLEARBOTH) (SAVEACS) (CLRPVARS)))
02200
02300 (DFUNC (CLEARBOTH) (PROGN (CLRCCLST NIL T) (CLRSPECS)))
02400
02500 (DFUNC (CLEARAC ACNO) (PROGN (CPUSH ACNO) (SETSLOT ACNO NIL)))
02600
02700 (DFUNC (CLEARITALL) (PROGN (CLEARBOTH) (CLEARACS)))
02800
02900 (DFUNC (CLEARACS)
03000 (PROG (ACNO)
03100 (SETQ ACNO NACS)
03200 LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
03300 (CLEARAC ACNO)
03400 (SETQ ACNO (SUB1 ACNO))
03500 (GO LOOP)))
03600
03700 (DFUNC (CLRCCLST DATA FL)
03800 (PROG (CCL)
03900 (SETQ CCL CCLST)
04000 LOOP (COND ((NULL CCL) (COND (FL (SETQ CCLST NIL))) (RETURN NIL)))
04100 (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
04200 (CSFUN (CAR CCL) VALUEAC)
04300 ELOOP(SETQ CCL (CDR CCL))
04400 (GO LOOP)))
04500
04600
00100 (DFUNC (CLRLOCS)
00200 (PROG (LDL VARLOC LOCCONT)
00300 (SETQ LDL LDLST)
00400 LOOP (COND ((NULL LDL) (RETURN NIL)))
00500 (COND ((ASSOC (CAAR LDL) LOCVARS) (GO ISVAR)))
00600 ELOOP(SETQ LDL (CDR LDL))
00700 (GO LOOP)
00800 ISVAR(SETQ VARLOC (LOC (CAR LDL)))
00900 (COND ((NOT (NUMBERP VARLOC)) (GO PUSH)))
01000 (SETQ LOCCONT (SLOTCONT VARLOC))
01100 (COND ((NOT (DVP LOCCONT))
01200 (SETSLOT VARLOC (CONS (CAAR LDL) P2CNT))
01300 (GO ELOOP))
01400 ((NUMBERP (CDR LOCCONT)) (GO ELOOP)))
01500 PUSH (SLOTPUSH (CONS (CAAR LDL) P2CNT))
01600 (OUTPUSH VARLOC)
01700 (GO ELOOP)))
01800
01900 (DFUNC (CLRPVARS)
02000 (PROG NIL
02100 (COND ((NOT PROGSW) (RETURN NIL)))
02200 (SETQ PROGSW NIL)
02300 LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
02400 (SETQ MINDEPTH (PDLDEPTH))
02500 (RETURN NIL))
02600 ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
02700 (SLOTPUSH (LIST (CAR PROGVARS)))
02800 (OUTPUSH (Q ((QUOTE NIL))))))
02900 (SETQ PROGVARS (CDR PROGVARS))
03000 (GO LOOP)))
03100
03200 (DFUNC (CLRSPECS)
03300 (PROG (LDL)
03400 (SETQ LDL LDLST)
03500 LOOP (COND ((NULL LDL) (RETURN NIL)))
03600 (COND ((SPECVARP (CAAR LDL)) (CLRSPVAR (CAR LDL))))
03700 (SETQ LDL (CDR LDL))
03800 (GO LOOP)))
03900
04000 (DFUNC (CLRSPVAR L)
04100 (PROG (LOC)
04200 (SETQ LOC (ILOC L VALUEAC))
04300 (COND ((NOT (NUMBERP LOC))
04400 (SLOTPUSH (CONS (CAR L) P2CNT))
04500 (OUTPUSH (LIST (Q SPECIAL) (CAR L))))
04600 ((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
04700 (RETURN NIL)))
04800
04900 (DFUNC (CLRTRASH VARS CNT)
05000 (PROG2 (CLRTRASH1 ACS VARS CNT) (CLRTRASH1 PDL VARS CNT)))
05100
05200
00100 (DFUNC (CLRTRASH1 LST VARS CNT)
00200 (PROG NIL
00300 LOOP (COND ((NULL LST) (RETURN NIL)))
00400 (COND ((AND (NOT (NULL (CAR LST)))
00500 (SPECVARP (CAAR LST))
00600 (MEMQ (CAAR LST) VARS)
00700 (OR (NULL (CDAR LST)) (GREATERP (CDAR LST) CNT)))
00800 (RPLACA LST NIL)))
00900 (SETQ LST (CDR LST))
01000 (GO LOOP)))
01100
01200 (DFUNC (COMPARGS ARGS)
01300 (PROG (ARGNO RESULT)
01400 (SETQ ARGNO 0)
01500 LOOP (COND ((NULL ARGS) (RETURN RESULT)))
01600 (SETQ ARGNO (ADD1 ARGNO))
01700 (SETQ RESULT (CONS (COMPEXPR (CAR ARGS) ARGNO) RESULT))
01800 (SETQ ARGS (CDR ARGS))
01900 (GO LOOP)))
02000
02100 (DFUNC (COMPEXPR XPR VALAC) (COMPFORM XPR VALAC NIL))
02200
02300 (DFUNC (COMPPRED XPR TEST) (COMPFORM XPR NIL TEST))
02400
02500 (DFUNC (COMPFORM XPR VALAC TEST)
02600 (PROG (TEM)
02700 (COND ((ATOM XPR) (GO ATOM)))
02800 (COND ((ATOM (CAR XPR)) (GO ATOMC)))
02900 (COND ((EQ (CAAR XPR) (Q LAMBDA))
03000 (RETURN (PASS2LAMBDA XPR VALAC TEST))))
03100 (RETURN (CALLFUNARGS XPR VALAC TEST))
03200 ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
03300 (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
03400 (RETURN (TESTJUMP TEM TEST))
03500 ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
03600 (RETURN ((PROPVAL TEM) XPR VALAC TEST))))
03700 (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
03800 (RETURN (CALLFUNARGS XPR VALAC TEST))))
03900 (COMPERR UNKNOWNFUNCTION-COMPFORM)))
04000
04100 (DFUNC (COMPSTAT XPR) (COMPFORM XPR NIL NIL))
04200
04300
00100 (DFUNC (COPT FUN AC ARGLOC)
00200 (PROG (CCL TEM YLOC)
00300 (SETQ YLOC (ILOC ARGLOC AC))
00400 (SETQ CCL CCLST)
00500 LOOP (COND ((NULL CCL) (RETURN NIL))
00600 ((AND (EQ FUN (CADAR CCL))
00700 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
00800 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
00900 (RETURN TEM)))
01000 (SETQ CCL (CDR CCL))
01100 (GO LOOP)))
01200
01300 (DFUNC (CPUSH ACNO)
01400 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
01500 (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
01600 (RETURN NIL)))
01700 (COND ((LESSP ACNO 1) (GO MAKE)))
01800 START(SETQ SLOTNO 0)
01900 (SETQ TEMPDL PDL)
02000 LOOP (COND ((NULL TEMPDL) (GO NONE)))
02100 (COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
02200 (COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
02300 (SPECVARP (CAAR TEMPDL)))
02400 (SETQ HOLDSLOT SLOTNO)))
02500 (COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
02600 ELOOP(SETQ TEMPDL (CDR TEMPDL))
02700 (SETQ SLOTNO (SUB1 SLOTNO))
02800 (GO LOOP)
02900 FOUND(SETSLOT SLOTNO SLOTCON)
03000 (COND ((NULL (CDR SLOTCON))
03100 (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
03200 (OUTMOVEM ACNO SLOTNO)
03300 (RETURN NIL)
03400 NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
03500 MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
03600 (SETQ TEMPDL (PDLDEPTH))
03700 (CLRPVARS)
03800 (COND ((LESSP ACNO 1)
03900 (SETQ ACNO (PLUS ACNO
04000 (DIFFERENCE TEMPDL
04100 (PDLDEPTH))))))))
04200 (SLOTPUSH SLOTCON)
04300 (SETSLOT ACNO
04400 (COND ((NULL (CDR SLOTCON))
04500 (CONS (CAR SLOTCON) (Q DUP)))
04600 (T NIL)))
04700 (OUTPUSH ACNO)
04800 (RETURN NIL)))
04900
05000
00100 (DFUNC (CSFUN L AC)
00200 (PROG (Y)
00300 (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
00400 (LOADCARCDR L AC)))))
00500
00600 (DFUNC (CSTEP FUN AC ARGLOC)
00700 (PROG (TEM)
00800 (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
00900 (COND ((SETQ TEM (COPT FUN AC ARGLOC)) (RETURN (LIST TEM))))
01000 (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
01100 (CSTEP (CDR TEM) AC ARGLOC)))))
01200
01300 (DFUNC (DOP2BOOL XPR VALAC TEST)
01400 (PROG (TG)
01500 (CLEARBOTH)
01600 (PUTPROP (SETQ TG (NEXTSYM TAG)) T (Q SET))
01700 (COND ((NOT (NULL VALAC))
01800 (RETURN (PROG (CTAG RSL)
01900 (BOOLEXPR XPR VALAC (CONS T TG))
02000 (RETURN (TESTJUMP (BOOLVALUE VALAC TG)
02100 TEST))))))
02200 (BOOLEXPR XPR VALAC (COND ((NULL TEST) (CONS T TG)) (T TEST)))
02300 (COND ((NULL TEST) (OUTENDTAG TG)))))
02400
02500 (DFUNC (DOP2ELSE XPR VALAC TEST)
02600 ((GETPROP (CAR XPR) (Q P2ELSE)) XPR VALAC TEST))
02700
02800 (DFUNC (DOP2VAL XPR VALAC TEST)
02900 (TESTJUMP ((GETPROP (CAR XPR) (Q P2VAL)) XPR VALAC TEST) TEST))
03000
03100
00100 (DFUNC (DVP X)
00200 (PROG (Y Z)
00300 (COND ((NULL X) (RETURN NIL)))
00400 (COND ((EQ (CDR X) (Q QT)) (RETURN NIL)))
00500 (COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
00600 (COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
00700 (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
00800 (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
00900 (NULL (CDR X))
01000 (LESSP P2CNT (CDR Y)))
01100 (RETURN T)))
01200 (SETQ Z LDLST)
01300 LOOP (COND ((NULL Z)
01400 (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
01500 (DVP (CONS (CDR Z) (CDR X))))
01600 (T NIL)))))
01700 (COND ((AND (EQ (CAAR Z) (CAR X))
01800 (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
01900 (T (CONS (CAR X) P2CNT))))
02000 (LOC (CAR Z))))
02100 (RETURN T)))
02200 (SETQ Z (CDR Z))
02300 (GO LOOP)))
02400
02500 (DFUNC (EQUIVTAG PTAG)
02600 (PROG (LTAG)
02700 (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
02800 (USERWARN PTAG UNDEFINED TAG)
02900 (RETURN EXIT)))
03000
03100 (DFUNC (EXITBUM SPECFLAG)
03200 (PROG (TEM1 TEM2)
03300 (COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
03400 (Q ((CALL JCALL) (PUSHJ JRST)))))
03500 (SETQ TEM2 (CAR LASTOUT))
03600 (SETQ LASTOUT NIL)
03700 (RESTORE NIL)
03800 (OUTINST TEM2)
03900 (COND ((NOT SPECFLAG)
04000 (SETQ TEM2 (CAR LASTOUT))
04100 (SETQ LASTOUT NIL)
04200 (OUTINST (MCONS (CADR TEM1)
04300 (SUBST 0 (Q P) (CADR TEM2))
04400 (CDDR TEM2)))
04500 (RETURN NIL)))))
04600 (RESTORE NIL)
04700 (COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
04800 (T (OUTINST (Q (POPJ P)))))))
04900
05000 (DFUNC (FREEAC) (FREEAC1 VALUEAC))
05100
05200
00100 (DFUNC (FREEAC1 BEST)
00200 (PROG (ACNO ACCS)
00300 (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
00400 (RETURN BEST)))
00500 (SETQ ACCS ACS)
00600 (SETQ ACNO 1)
00700 LOOP (COND ((NULL ACCS) (COND ((NULL BEST) (RETURN NIL))
00800 (T (CPUSH BEST) (RETURN BEST)))))
00900 (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
01000 (SETQ ACCS (CDR ACCS))
01100 (SETQ ACNO (ADD1 ACNO))
01200 (GO LOOP)))
01300
01400 (DFUNC (FINDFREEAC) (FREEAC1 NIL))
01500
01600 (DFUNC (FREEZE VAR) (PROGN (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
01700
01800 (DFUNC (FREEZE1 X Z)
01900 (PROG NIL
02000 LOOP (COND ((NULL Z) (RETURN NIL)))
02100 (COND ((EQ X (CAAR Z))
02200 (COND ((NULL (CDAR Z)) (RPLACA Z (CONS X P2CNT)))
02300 ((EQ (CDAR Z) (Q DUP)) (RPLACA Z NIL)))))
02400 (SETQ Z (CDR Z))
02500 (GO LOOP)))
02600
02700 (DFUNC (GENCONST OP AC AD IN IB)
02800 (PROG (ANS)
02900 (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
03000 (SETQ ANS (APPEND ANS (LIST AC AD IN)))
03100 (SETQ ANS (CONS OP ANS))
03200 (RETURN (CONS (Q C) ANS))))
03300
03400 (DFUNC (GETSLOT NO)
03500 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
03600 ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
03700 ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
03800 ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
03900 (COMPERR NOTONPDL-GETSLOT))
04000 ((NTHCDR (MINUS NO) PDL))))
04100
04200
00100 (DFUNC (ILOC X AC)
00200 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
00300 (COND ((NULL AC) (GO LOOK)))
00400 (COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
00500 LOOK (COND ((EQ (CDR X) (Q QT))
00600 (RETURN (LIST (LIST (Q QUOTE) (CAR X))))))
00700 (SETQ SL (APPEND ACS PDL))
00800 (SETQ CNTR 1)
00900 (SETQ BESTNO (ADD1 P2CNT))
01000 (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
01100 LOOP (COND ((NULL SL) (GO EXIT)))
01200 (SETQ SLOT (CAR SL))
01300 (COND ((AND SLOT (EQ (CAR X) (CAR SLOT))) (GO ISONE)))
01400 ELOOP(SETQ SL (CDR SL))
01500 (SETQ CNTR (ADD1 CNTR))
01600 (GO LOOP)
01700 EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
01800 (COND ((SPECVARP (CAR X))
01900 (RETURN (LIST (Q SPECIAL) (CAR X)))))
02000 (RETURN NIL)
02100 ISONE(COND ((OR (EQUAL X SLOT)
02200 (NOT (MEMQ (CDR SLOT) (Q (QT TAKEN)))))
02300 (SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT))
02400 (T P2CNT)))
02500 (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
02600 (SETQ BESTNO CNT)
02700 (SETQ BEST CNTR)))))
02800 (GO ELOOP)
02900 RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
03000 (T (PLUS (MINUS BEST) NACS 1))))))
03100
03200 (DFUNC (ILOC1 X AC)
03300 (PROG (Z)
03400 (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
03500 (COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
03600 (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
03700 (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
03800 (COND ((SETQ Z (ASSOC (CAR X) CCLST))
03900 (RETURN (LOADCARCDR Z
04000 (COND ((NULL AC) (FREEAC))
04100 (T AC))))))
04200 (PRINTMSG (LIST X))
04300 (COMPERR LOSTVAR-ILOC1)))
04400
04500 (DFUNC (LISTNILS N)
04600 (COND ((ZEROP N) NIL) (T (CONS NIL (LISTNILS (SUB1 N))))))
04700
04800
00100 (DFUNC (LOADARG ACNO VAR)
00200 (PROG (DATAORG OLDACC DATACONT DAC DOD)
00300 (REMOVE VAR)
00400 (COND ((NULL ACNO) (RETURN NIL)))
00500 (SETQ DATAORG (ILOC1 VAR ACNO))
00600 (SETQ OLDACC (SLOTCONT ACNO))
00700 (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
00800 (SETQ DAC (DVP OLDACC))
00900 (SETQ DOD (DVP DATACONT))
01000 (COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO)))
01100 (RETURN NIL)))
01200 (COND ((AND (EQ DATAORG 0)
01300 (NOT DOD)
01400 (NOT DAC)
01500 (GREATERP (PDLDEPTH) MINDEPTH))
01600 (GO POP)))
01700 (COND ((AND (NOT DOD)
01800 (NOT (NULL OLDACC))
01900 (NUMBERP DATAORG)
02000 (LESSP DATAORG ACNO))
02100 (GO EXCH)))
02200 (COND ((NOT DAC) (GO FREE)))
02300 (GO PUSH)
02400 EXCH (SETSLOT DATAORG OLDACC)
02500 (SETSLOT ACNO DATACONT)
02600 (OUT1 (Q EXCH) ACNO DATAORG)
02700 (RETURN NIL)
02800 PUSH (CPUSH ACNO)
02900 (SETQ DATAORG (LOC VAR))
03000 FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
03100 (SETSLOT ACNO
03200 (COND ((NULL (CDR DATACONT))
03300 (CONS (CAR DATACONT) (Q DUP)))
03400 (T DATACONT)))
03500 (OUTMOVE ACNO DATAORG)
03600 (RETURN NIL)
03700 POP (SETSLOT ACNO DATACONT)
03800 (OUTPOP ACNO)
03900 (RETURN NIL)
04000 MOVE (SETSLOT ACNO
04100 (COND ((EQ (CAAR DATAORG) (Q QUOTE))
04200 (CONS (CADAR DATAORG) (Q QT)))
04300 (T (LIST (CAR VAR)))))
04400 (OUTMOVE ACNO DATAORG)
04500 (RETURN NIL)))
04600
04700
00100 (DFUNC (LOADCARCDR ITEM AC)
00200 (PROG (ARG PATH ORIG)
00300 (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
00400 (REMOVE ARG)))
00500 (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
00600 (COND ((NULL (CDR PATH))
00700 (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
00800 VARLIST))
00900 (REMOVE ARG)
01000 (RETURN (LOC (CAR PATH)))))
01100 (SETQ PATH (REVERSE PATH))
01200 (CPUSH AC)
01300 (SETQ ORIG (LOC (CAR PATH)))
01400 (SETQ PATH (CDR PATH))
01500 (REMOVE ARG)
01600 L1 (COND ((NULL PATH) (GO RET)))
01700 (COND ((NULL (CDR PATH)) (GO L2)))
01800 (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
01900 (OUTCALL 1
02000 (READLIST (CONS (Q C)
02100 (REVERSE (CONS (Q R) PATH)))))
02200 (GO RET)))
02300 L2 (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
02400 AC
02500 ORIG)
02600 (SETQ PATH (CDR PATH))
02700 (SETQ ORIG AC)
02800 (GO L1)
02900 RET (SETSLOT AC (LIST (CAR ITEM)))
03000 (RETURN AC)))
03100
03200 (DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMPEXPR XPR AC)))
03300
03400 (DFUNC (LOADSUBRARGS ARGS)
03500 (PROG (ARGNO)
03600 (SETQ ARGNO (LENGTH ARGS))
03700 LOOP (COND ((NULL ARGS) (RETURN NIL)))
03800 (LOADARG ARGNO (CAR ARGS))
03900 (SETQ ARGS (CDR ARGS))
04000 (SETQ ARGNO (SUB1 ARGNO))
04100 (GO LOOP)))
04200
04300 (DFUNC (LOC X) (ILOC1 X NIL))
04400
04500 (DFUNC (MARKVAL FLAG LOC)
04600 (PROG (VAR GVAL)
04700 (COND ((NULL LOC) (RETURN NIL)))
04800 (SETQ GVAL (NEXTSYM VAL))
04900 (SETQ VAR (CAR (SETSLOT LOC (LIST GVAL))))
05000 (COND ((NOT (NULL FLAG)) (SETQ LDLST (CONS VAR LDLST))))
05100 (RETURN VAR)))
05200
05300
00100 (DFUNC (NONSPECVARS VRS)
00200 (PROG (ANS)
00300 LOOP (COND ((NULL VRS) (RETURN ANS))
00400 ((SPECVARP (CAR VRS)))
00500 (T (SETQ ANS (CONS (CAR VRS) ANS))))
00600 (SETQ VRS (CDR VRS))
00700 (GO LOOP)))
00800
00900 (DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
01000
01100 (DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
01200
01300 (DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
01400
01500 (DFUNC (OUTCJMP FLAG AC ADRESS)
01600 (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
01700
01800 (DFUNC (OUTENDTAG X)
01900 (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
02000
02100 (DFUNC (OUTFUNCALL TYPE NUM FUN)
02200 (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
02300
02400 (DFUNC (OUTGOTAB X)
02500 (PROG (ETAG)
02600 (SETQ ETAG (NEXTSYM TAG))
02700 (PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
02800 (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
02900 (OUTTAG (CAR X))
03000 LOOP (SETQ X (CDR X))
03100 (COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
03200 (OUTTAG ETAG)
03300 (RETURN NIL)))
03400 (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
03500 (OUTJRST (CDAR X))
03600 (GO LOOP)))
03700
03800 (DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
03900
04000 (DFUNC (OUTJMP OP AC ADR)
04100 (PROGN (SAVEACS)
04200 (CLEARBOTH)
04300 (RST ADR)
04400 (PUTPROP ADR T (Q USED))
04500 (OUTINST (LIST OP AC ADR))))
04600
04700 (DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
04800
04900 (DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
05000
05100 (DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
05200
05300
00100 (DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (Q POP) (Q P) L)))
00200
00300 (DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))
00400
00500 (DFUNC (OUTPUTSTAT ST)
00600 (PROG (ADD)
00700 (COND ((ATOM ST) (GO PRINT)))
00800 (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
00900 (SETQ CODESIZE (ADD1 CODESIZE))
01000 (SETQ ADD (CADDR ST))
01100 (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
01200 (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
01300 PRINT(PRINTSTAT ST)))
01400
01500 (DFUNC (OUTSTAT ST)
01600 (PROG (COL EXPRS)
01700 (COND ((NULL LASTOUT) (GO SETIT)))
01800 (OUTPUTSTAT (CAR LASTOUT))
01900 (SETQ COL (CURCOL))
02000 (SETQ EXPRS (CDR LASTOUT))
02100 TRACE(COND ((NULL EXPRS) (GO SETIT)))
02200 (TABTO COL)
02300 (PRINTEXPR (CAR EXPRS))
02400 (SETQ EXPRS (CDR EXPRS))
02500 (GO TRACE)
02600 SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
02700 (RETURN NIL)))
02800
02900 (DFUNC (P2*EVAL XPR VALAC TEST)
03000 (PROG (ARG TEM VAL)
03100 (SETQ ARG (CADR XPR))
03200 (COND ((AND (EQ (CAR ARG) (Q CONS))
03300 (EQ (CAADR ARG) (Q QUOTE))
03400 (GETL (SETQ TEM (CADADR ARG))
03500 (Q (FEXPR FSUBR *FSUBR))))
03600 (GO NOCONS)))
03700 (RETURN (CALLSUBR XPR VALAC TEST))
03800 NOCONS
03900 (LOADCOMP (CADDR ARG) VALUEAC)
04000 (PROTECTACS TEM)
04100 (SETQ VAL (MARKVAL (NOT (NULL VALAC)) VALUEAC))
04200 (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
04300 (RETURN VAL)))
04400
04500
00100 (DFUNC (P2ARG XPR VALAC TEST)
00200 (PROG (ARG)
00300 (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
00400 (COND ((EQ (CDR ARG) (Q QT))
00500 (CPUSH VALAC)
00600 (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
00700 (REMOVE ARG)
00800 (OUTINST (LIST (Q HRRZ) VALAC (CAR ARG) VALAC))
00900 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
01000 (LOADARG VALAC ARG)
01100 (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
01200 (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
01300 (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
01400
01500 (DFUNC (P2CARCDR XPR VALAC TEST)
01600 (PROG (TEM AC)
01700 (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
01800 (USERERR ARGNOERR-P2CARCDR)))
01900 (COND ((AND (NULL VALAC) (NULL TEST))
02000 (RETURN (COMPSTAT (CADR XPR)))))
02100 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
02200 (SETQ XPR (CONS (SETQ TEM (GENSYM))
02300 (CONS (CAR XPR) (COMPEXPR (CADR XPR) AC))))
02400 (SETQ CCLST (CONS XPR CCLST))
02500 (SETQ TEM (LIST TEM))
02600 (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
02700 (RETURN (TESTJUMP TEM TEST))))
02800
02900 (DFUNC (P2COND XPR VALAC TEST)
03000 (PROG (AC CTAG RSL VALF)
03100 (CLRLOCS)
03200 (CLEAR1)
03300 (SETQ VALF (OR (NOT (NULL VALAC)) (NOT (NULL TEST))))
03400 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
03500 (P2COND1 (CDR XPR) VALF AC MINDEPTH)
03600 (INCR P2CNT)
03700 (INCR P2CNT)
03800 (RETURN (MARKVAL VALF AC))))
03900
04000
00100 (DFUNC (P2COND1 ARGS VALF AC MINDEPTH)
00200 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST)
00300 (SETQ CONDEXIT (NEXTSYM TAG))
00400 (SETQ IRSSL (TOPCOPY PDL))
00500 (SETQ MINDEPTH (PDLDEPTH))
00600 (PUTPROP CONDEXIT IRSSL (Q LEVEL))
00700 LOOP (SETQ RSL NIL)
00800 (COND ((NULL ARGS) (COND (RETNIL (LOADARG AC (Q (NIL . QT)))))
00900 (OUTENDTAG CONDEXIT)
01000 (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
01100 (RESTORE IRSSL)
01200 (RETURN NIL)))
01300 (SETQ PAIR (CAR ARGS))
01400 (COND ((NULL (CDR PAIR))
01500 (LOADCOMP (CAR PAIR) AC)
01600 (COND ((NOT (NULL (CDR ARGS))) (OUTCJMP T AC CONDEXIT))
01700 (T (RESTORE IRSSL)))
01800 (GO NONIL)))
01900 (COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
02000 (EQ (CAAR PAIR) (Q NULL))
02100 (OR (ATOM (CADAR PAIR))
02200 (NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
02300 (LOADCOMP (CADAR PAIR) AC)
02400 (OUTCJMP NIL AC CONDEXIT)
02500 (SETQ RETNIL T)
02600 (GO ELOOP)))
02700 (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
02800 (COND ((AND (EQ (CAADR PAIR) (Q GO))
02900 (ATOM (SETQ ATAG (CADADR PAIR))))
03000 (COMPPRED (CAR PAIR) (CONS T (EQUIVTAG ATAG)))
03100 (GO NONIL)))
03200 (COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
03300 (COMPPRED (CAR PAIR) (CONS T EXITN))
03400 (GO NONIL)))
03500 L2 (SETQ PAIREXIT (SETQ CTAG (NEXTSYM TAG)))
03600 (PUTPROP PAIREXIT IRSSL (Q LEVEL))
03700 (SETQ RSL NIL)
03800 (COMPPRED (CAR PAIR) (CONS NIL PAIREXIT))
03900 (SETQ H2 (COND ((NOT (ATOM RSL)) RSL)
04000 (T (LIST (TOPCOPY ACS) (TOPCOPY PDL)))))
04100 (SETQ H1 (TOPCOPY CCLST))
04200 (SETQ REST (CDR PAIR))
04300 LP1 (COND ((NULL (CDR REST)) (GO L1)))
04400 (COMPSTAT (CAR REST))
04500 (SETQ REST (CDR REST))
04600 (GO LP1)
04700 L1 (COND ((NULL VALF) (COMPSTAT (CAR REST)))
04800 (T (LOADCOMP (CAR REST) AC)))
04900 (SAVEACS)
05000 (SETQ CCLST H1)
05100 (SETQ H1 ACS)
05200 (SETQ ACS (CAR H2))
05300 (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (NIL . QT))))
05400 (SETQ ACS H1)
05500 (SETQ RETNIL NIL)
05600 (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
05700 (COND ((OR (NOT (NULL (CDR ARGS)))
05800 (AND VALF
05900 (NOT ACNIL)
06000 (SETQ RETNIL (USEDTAGP PAIREXIT))))
06100 (OUTJRST CONDEXIT))
06200 (T (RESTORE IRSSL)))))
06300 (SETQ ACS (CAR H2))
06400 (SETQ PDL (CADR H2))
06500 (SETQ PDLDEPTH (LENGTH PDL))
06600 (COND ((USEDTAGP PAIREXIT) (OUTTAG PAIREXIT)))
06700 (GO ELOOP)
06800 NONIL(SETQ RETNIL NIL)
06900 ELOOP(SETQ ARGS (CDR ARGS))
07000 (GO LOOP)))
07100
07200
00100 (DFUNC (P2GO XPR VALAC TEST)
00200 (PROG (TAG)
00300 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
00400 (USERERR GO FOR VALUE OR TEST P2GO)))
00500 (SETQ TAG (CADR XPR))
00600 (SAVEACS)
00700 (CLRPVARS)
00800 (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
00900 (T (LOADCOMP TAG GOTABAC) (OUTJRST VGO)))
01000 (RETURN (MARKVAL (NOT (NULL VALAC)) VALUEAC))))
01100
01200
00100 (DFUNC (P2PROG XPR VALAC TEST)
00200 (PROG (PSFLG PVR)
00300 (SETQ PVR (COND ((NOT (NULL VALAC)) VALAC)
00400 ((NOT (NULL TEST)) (FREEAC))
00500 (T NIL)))
00600 (SETQ PSFLG (SPECBIND (CADDR XPR) NIL))
00700 (SETQ PRGSPFLG NIL)
00800 (CLEAR1)
00900 (PROG (GOLIST EXIT EXITN PRSSL PROGSW VGO)
01000 (CLRLOCS)
01100 (INCR P2CNT)
01200 (SETQ PROGSW T)
01300 (SETQ EXIT (NEXTSYM TAG))
01400 (SETQ EXITN (NEXTSYM TAG))
01500 (SETQ VGO (NEXTSYM TAG))
01600 (SETQ GOLIST (CONS (CONS NIL EXIT)
01700 (CONS (CONS NIL EXITN)
01800 (CONS (CONS NIL VGO)
01900 (CADR XPR)))))
02000 (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
02100 (SETQ XPR (CDDDR XPR))
02200 LOOP (COND ((NULL XPR) (GO EXITN)))
02300 (INCR P2CNT)
02400 (COND ((NOT PROGSW) (RESTORE PRSSL)))
02500 (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
02600 ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
02700 (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL))))
02800 (GO EXITN))
02900 (T (LOADCOMP (CADAR XPR) PVR)
03000 (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
03100 (GO EXITN))
03200 (T (GO EXIT))))))
03300 (T (COMPSTAT (CAR XPR))))
03400 (SETQ XPR (CDR XPR))
03500 (GO LOOP)
03600 EXITN(OUTENDTAG EXITN)
03700 (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
03800 (LOADARG PVR (Q (NIL . QT)))))
03900 EXIT (OUTENDTAG EXIT)
04000 (INCR P2CNT)
04100 (INCR P2CNT)
04200 (COND ((USEDTAGP VGO)
04300 (OUTGOTAB (CONS VGO (CDDDR GOLIST))))))
04400 (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
04500 (RETURN (MARKVAL (NOT (NULL PVR)) PVR))))
04600
04700
00100 (DFUNC (P2PROG2 XPR VALAC TEST)
00200 (PROG (ARGS ARG2)
00300 (SETQ ARGS (CDR XPR))
00400 (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
00500 (COMPSTAT (CAR ARGS))
00600 (COND ((NULL (CDDR ARGS))
00700 (RETURN (COMPFORM (CADR ARGS) VALAC TEST))))
00800 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
00900 (SETQ ARG2 (COMPEXPR (CADR ARGS) VALAC)))
01000 (T (COMPSTAT (CADR ARGS))))
01100 (SETQ ARGS (CDDR ARGS))
01200 LOOP (COND ((NULL ARGS) (RETURN (TESTJUMP ARG2 TEST))))
01300 (COMPSTAT (CAR ARGS))
01400 (SETQ ARGS (CDR ARGS))
01500 (GO LOOP)))
01600
01700 (DFUNC (P2PROGN XPR VALAC TEST)
01800 (PROG (ARGS)
01900 (COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
02000 LOOP (COND ((NULL (CDR ARGS))
02100 (RETURN (COMPFORM (CAR ARGS) VALAC TEST))))
02200 (COMPSTAT (CAR ARGS))
02300 (SETQ ARGS (CDR ARGS))
02400 (GO LOOP)))
02500
02600 (DFUNC (P2QUOTE XPR VALAC TEST)
02700 (PROG2 (COND ((NOT (NULL TEST))
02800 (BOOLARGS NIL
02900 (IFIF (CAR TEST) (CADR XPR))
03000 (CDR TEST)
03100 NIL)))
03200 (CONS (CADR XPR) (Q QT))))
03300
03400 (DFUNC (P2RETURN XPR VALAC TEST)
03500 (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
03600 (USERERR RETURN FOR VALUE OR TEST P2RETURN))
03700 (T (SAVEACS)
03800 (CLRPVARS)
03900 (COND ((EQUAL (CADR XPR) (Q (QUOTE NIL))) (OUTJRST EXITN))
04000 (T (LOADCOMP (CADR XPR) PVR) (OUTJRST EXIT))))))
04100
04200
00100 (DFUNC (P2RPLAC XPR VALAC TEST)
00200 (PROG (ARG1 ARG2)
00300 (SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
00400 (SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
00500 (ILOC1 ARG1 VALAC)
00600 (LOC ARG2)
00700 (CLEARBOTH)
00800 (COND ((EQUAL ARG2 (Q (NIL . QT)))
00900 (OUT1 (CADR (ASSOC (CAR XPR)
01000 (Q ((RPLACA HRRZS@)
01100 (RPLACD HLLZS@)))))
01200 0
01300 (LOC ARG1)))
01400 (T (OUT1 (CADR (ASSOC (CAR XPR)
01500 (Q ((RPLACA HRLM@)
01600 (RPLACD HRRM@)))))
01700 (PUTINAC ARG2 (FREEAC))
01800 (LOC ARG1))))
01900 (REMOVE ARG2)
02000 (COND ((NULL VALAC) (REMOVE ARG1)))
02100 (RETURN ARG1)))
02200
02300 (DFUNC (P2SETARG XPR VALAC TEST)
02400 (PROG (TEM)
02500 (LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
02600 (COND ((EQ (CAADR XPR) (Q QUOTE))
02700 (OUT1 (Q MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
02800 (RETURN (OUTINST (LIST (Q HRRM)
02900 (PUTINAC TEM VALAC)
03000 (CADADR XPR)
03100 2)))))
03200 (LOADCOMP (COMPEXPR (CADR XPR)) 2)
03300 (CLEARACS)
03400 (OUT1 (Q ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
03500 (OUTINST (LIST (Q HRRM)
03600 (PUTINAC TEM VALAC)
03700 (MINUS INUM0)
03800 2))))
03900
04000
00100 (DFUNC (P2SETQ XPR VALAC TEST)
00200 (PROG (NVAR VALLOC HOME VAR VAL TEM AC)
00300 (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
00400 (SETQ VAR (CADR XPR))
00500 (SETQ VAL (COMPEXPR (CADDR XPR) AC))
00600 (ILOC1 VAL AC)
00700 (COND ((AND (SPECVARP VAR) (SETQ TEM (ASSOC VAR LDLST)))
00800 (CLRSPVAR TEM)))
00900 (REMOVE VAL)
01000 (FREEZE VAR)
01100 (SETQ VALLOC (LOC VAL))
01200 (SETQ HOME (COND ((SPECVARP VAR) T)
01300 ((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
01400 NIL)
01500 (T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
01600 (INCR P2CNT)
01700 (COND ((AND (NULL VALAC) (NOT HOME))
01800 (COND ((AND (NUMBERP VALLOC)
01900 (NOT (DVP (SLOTCONT VALLOC))))
02000 (SETSLOT VALLOC (LIST VAR))
02100 (GO EXIT))
02200 (T (SLOTPUSH (LIST VAR))
02300 (OUTPUSH VALLOC)
02400 (GO EXIT)))))
02500 (COND ((AND HOME (EQUAL VAL (Q (NIL . QT))))
02600 (SETQ VAL (COND ((SPECVARP VAR) (LIST (Q SPECIAL) VAR))
02700 (T (ILOC (CONS VAR (SUB1 P2CNT)) AC))))
02800 (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
02900 (COND ((OR (NULL VALAC) (DVP (SLOTCONT AC)))
03000 (OUT1 (Q CLEARM) 0 VAL))
03100 (T (SETSLOT AC (CONS VAR (Q DUP)))
03200 (OUT1 (Q CLEARB) AC VAL)))
03300 (GO EXIT)))
03400 (COND ((OR (NOT (NUMBERP VALLOC))
03500 (LESSP VALLOC 0)
03600 (DVP (SLOTCONT VALLOC)))
03700 (LOADARG AC VAL)
03800 (SETQ VALLOC AC)))
03900 (SETSLOT VALLOC (LIST VAR))
04000 (COND ((SPECVARP VAR)
04100 (COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
04200 (T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
04300 EXIT (RETURN (COMPFORM VAR VALAC TEST))))
04400
04500
00100 (DFUNC (P2STORE XPR VALAC TEST)
00200 (PROG (TEM)
00300 (LOC (SETQ TEM (COMPEXPR (CADDR XPR)
00400 (COND ((NULL VALAC) (FREEAC))
00500 (T VALAC)))))
00600 (COMPSTAT (CADR XPR))
00700 (LOADARG ARRAYAC TEM)
00800 (OUTINST (Q (PUSHJ P NSTR)))
00900 (RETURN TEM)))
01000
01100 (DFUNC (PASS2 NAME EXPR FLAG)
01200 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPECFLAG PRGSPFLG CCLST
01300 VARLIST PROGVARS PROGSW GOLIST CTAG RSL)
01400 (SETQ P2CNT 1)
01500 (SETQ ACS (LISTNILS NACS))
01600 (SETQ ALLACS (SUB1 (LSH 1 NACS)))
01700 (SETQ PDL NIL)
01800 (SETQ PDLDEPTH (LENGTH PDL))
01900 (SETQ MINDEPTH (PDLDEPTH))
02000 (BINDARGS (CADR EXPR))
02100 (COND ((NOT (ATMARGIN)) (LINEF 2)))
02200 (OUTPSOP (LIST (Q LAP) NAME FLAG))
02300 (COND ((EQ (CAR EXPR) (Q FSUBR))
02400 (COND ((NOT (NULL (CDADR EXPR)))
02500 (OUTINST (Q (PUSHJ P *AMAKE))))))
02600 ((EQ (CAR EXPR) (Q LSUBR))
02700 (OUTINST (Q (JSP 3 *LCALL)))
02800 (INITPROP (Q ARG) (Q P2) (Q P2ARG))))
02900 (SETQ SPECFLAG (SPECBIND (CADR EXPR) T))
03000 (COND ((NOT (EQ (CAADDR EXPR) (Q PROG))) (SETQ PRGSPFLG NIL)))
03100 (LOADCOMP (CADDR EXPR) VALUEAC)
03200 (EXITBUM SPECFLAG)
03300 (OUTINST (OUTINST NIL))
03400 (COND ((EQ (CAR EXPR) (Q LSUBR)) (DELETEPROP (Q ARG) (Q P2))))
03500 (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
03600 (RETURN NIL)))
03700
03800
00100 (DFUNC (PASS2LAMBDA XPR VALAC TEST)
00200 (PROG (BODY ARGS SF VARS VAL LOC SAVCNT TEM)
00300 (SETQ BODY (CADDAR XPR))
00400 (SETQ VARS (CADAR XPR))
00500 (SETQ ARGS (REVERSE (COMPARGS (CDR XPR))))
00600 (SETQ SAVCNT P2CNT)
00700 (INCR P2CNT)
00800 A (COND ((NULL VARS) (GO B)))
00900 (SETQ LOC (LOC (CAR ARGS)))
01000 (REMOVE (CAR ARGS))
01100 (COND ((SPECVARP (CAR VARS))
01200 (SETQ SF T)
01300 (FREEZE (CAR VARS))
01400 (SETQ LOC (PUTINAC (CAR ARGS) (FREEAC))))
01500 ((OR (NOT (NUMBERP LOC))
01600 (DVP (SETQ TEM (SLOTCONT LOC))))
01700 (SLOTPUSH TEM)
01800 (COND ((NULL (CDR TEM))
01900 (SETSLOT LOC (CONS (CAR TEM) (Q DUP)))))
02000 (OUTPUSH LOC)
02100 (SETQ LOC 0)))
02200 (SETSLOT LOC (CONS (CAR VARS) (Q TAKEN)))
02300 (SETQ ARGS (CDR ARGS))
02400 (SETQ VARS (CDR VARS))
02500 (GO A)
02600 B (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
02700 (SETQ VARS (CADAR XPR))
02800 C (COND ((NULL VARS) (GO D)))
02900 (SETQ LOC (ILOC (CONS (CAR VARS) (Q TAKEN)) NIL))
03000 (COND ((SPECVARP (CAR VARS))
03100 (OUTINST (LIST 0 LOC (LIST (Q SPECIAL) (CAR VARS))))))
03200 (RPLACD (SLOTCONT LOC) NIL)
03300 (SETQ VARS (CDR VARS))
03400 (GO C)
03500 D (SETQ TEM (COMPEXPR BODY VALAC))
03600 (SETQ LOC (LOC TEM))
03700 (SETQ VAL (MARKVAL VALAC
03800 (COND ((NUMBERP LOC) LOC)
03900 (T (PUTINAC TEM (FREEAC))))))
04000 (REMOVE TEM)
04100 (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
04200 (INCR P2CNT)
04300 (CLRTRASH (CADAR XPR) SAVCNT)
04400 (RETURN (TESTJUMP VAL TEST))))
04500
04600 (DFUNC (PROGTAG TAG)
04700 (PROGN (CLEARBOTH)
04800 (CLEARACS)
04900 (CLRPVARS)
05000 (RESTORE PRSSL)
05100 (OUTTAG (EQUIVTAG TAG))))
05200
05300
00100 (DFUNC (PROTECTACS X)
00200 (PROG (WHICHACS ACNO)
00300 (SETQ WHICHACS (ACEFFECTS X))
00400 (SETQ ACNO 0)
00500 LOOP (SETQ ACNO (ADD1 ACNO))
00600 (COND ((ZEROP WHICHACS) (RETURN NIL))
00700 ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
00800 (SETQ WHICHACS (LSH WHICHACS -1))
00900 (GO LOOP)))
01000
01100 (DFUNC (PUTINAC X AC)
01200 (PROG (Z)
01300 (SETQ Z (LOC X))
01400 (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
01500 (REMOVE X)
01600 (CPUSH Z)
01700 (RETURN Z)))
01800
01900 (DFUNC (REMOVE DATA)
02000 (PROG (TEM)
02100 (SETQ TEM (GETPROP (Q LDLST) (Q VALUE)))
02200 LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
02300 (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
02400 (T (SETQ TEM (CDR TEM))))
02500 (GO LOOP)))
02600
02700
00100 (DFUNC (RESTORE OLDPDL)
00200 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
00300 (SETQ OLDDEPTH (LENGTH OLDPDL))
00400 (COND ((GREATERP OLDDEPTH (PDLDEPTH))
00500 (PRINTMSG (LIST OLDPDL PDL))
00600 (COMPERR PDLSHORT-RESTORE)))
00700 A1 (SETQ C 0)
00800 A (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
00900 ((DVP (SETQ R (CAR PDL))) (GO CPP)))
01000 (SETQ C (ADD1 C))
01100 (SLOTPOP)
01200 (GO A)
01300 CPP (SHRINKPDL C)
01400 CPP1 (SETQ V OLDPDL)
01500 (SETQ C 0)
01600 (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
01700 CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
01800 (COND ((NULL V) (COMPERR NOAC-RESTORE)))
01900 (SETSLOT V R)
02000 (OUTPOP V)
02100 (GO A1))
02200 ((AND (CAR V)
02300 (EQ (CAAR V) (CAR R))
02400 (NOT (DVP (SLOTCONT (SETQ TEM
02500 (MINUS (PLUS C
02600 DEPTHDIF)))))))
02700 (GO CPP2)))
02800 (SETQ C (ADD1 C))
02900 (SETQ V (CDR V))
03000 (GO CPP3)
03100 CPP2 (SETSLOT TEM R)
03200 (OUTPOP TEM)
03300 (GO A1)))
03400
03500 (DFUNC (RSLSET X)
03600 (COND ((EQ X CTAG)
03700 (SETQ RSL (COND ((AND RSL
03800 (NOT (AND (EQUAL (CAR RSL) ACS)
03900 (EQUAL (CADR RSL) PDL))))
04000 (Q LOSE))
04100 (T (LIST (TOPCOPY ACS) (TOPCOPY PDL))))))))
04200
04300 (DFUNC (RST TAG)
04400 (COND ((NULL TAG) NIL)
04500 ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
04600 ((REMPROP TAG (Q SET)) (SAVEACS)
04700 (PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
04800 (SETQ MINDEPTH (PDLDEPTH)))
04900 ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
05000 (T (COMPERR NIL-RST))))
05100
05200
00100 (DFUNC (SAVEACS)
00200 (PROG (K)
00300 (SETQ K 0)
00400 LOOP (COND ((EQ K NACS) (RETURN NIL)))
00500 (CPUSH (SETQ K (ADD1 K)))
00600 (GO LOOP)))
00700
00800 (DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
00900
01000 (DFUNC (SHRINKPDL C)
01100 (COND ((NOT (ZEROP C))
01200 (OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))
01300
01400 (DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))
01500
01600 (DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
01700
01800 (DFUNC (SLOTPOP)
01900 (PROGN (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
02000
02100 (DFUNC (SLOTPUSH SC)
02200 (PROGN (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
02300
02400 (DFUNC (SPECBIND VARS LAMBDAP)
02500 (PROG (ACNUM SPFLG)
02600 (SETQ ACNUM 1)
02700 LOOP (COND ((NULL VARS) (RETURN SPFLG)))
02800 (COND ((NOT (SPECVARP (CAR VARS))) (GO ELOOP)))
02900 (COND ((NOT PRGSPFLG) (SETQ PRGSPFLG (SETQ SPFLG T))
03000 (OUTINST (Q (JSP 6 SPECBIND)))))
03100 (OUTINST (LIST 0
03200 (COND (LAMBDAP ACNUM) (T 0))
03300 (LIST (Q SPECIAL) (CAR VARS))))
03400 ELOOP(SETQ ACNUM (ADD1 ACNUM))
03500 (SETQ VARS (CDR VARS))
03600 (GO LOOP)))
03700
03800 (DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
03900
04000
00100 (DFUNC (TESTJUMP ITEM TEST)
00200 (PROG (AC FLAG TAG)
00300 (COND ((NULL TEST) (RETURN ITEM)))
00400 (SETQ FLAG (CAR TEST))
00500 (SETQ TAG (CDR TEST))
00600 (SETQ AC (PUTINAC ITEM (FREEAC)))
00700 (OUTCJMP FLAG AC TAG)
00800 (COND (FLAG (RSLSET TAG) (SETSLOT AC (Q (NIL . QT))))
00900 (T (SETQ FLAG (SLOTCONT AC))
01000 (SETSLOT AC (Q (NIL . QT)))
01100 (RSLSET TAG)
01200 (SETSLOT AC FLAG)))
01300 (RETURN ITEM)))
01400
01500 (DFUNC (TRANSOUT OP AC AD)
01600 (PROG (TEM IND)
01700 (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
01800 (SETQ AD (CAR AD))
01900 (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
02000 (SETQ OP (PROPVAL TEM))
02100 (GO DONE)))
02200 (SETQ AD (GENCONST 0 0 AD 0 0))
02300 DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
02400 (T (LIST (Q P)))))
02500 (RETURN (MCONS OP AC AD IND))))
02600
02700 (DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
02800
02900 (MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
03000 (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
03100 (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
03200 (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR)
03300 (P2BOOL DOP2BOOL) (P2ELSE DOP2ELSE) (P2VAL DOP2VAL))
03400
03500 (MAPDEF P2BOOL (AND BOOLAND) (NULL BOOLNULL) (OR BOOLOR))
03600
03700 (MAPDEF P2ELSE (EQ BOOLEQ) (GO P2GO) (QUOTE P2QUOTE) (PROG2 P2PROG2)
03800 (RETURN P2RETURN) (SETQ P2SETQ))
03900
04000 (MAPDEF P2VAL (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND) (PROG P2PROG)
04100 (PROGN P2PROGN) (RETURN P2RETURN) (RPLACA P2RPLAC)
04200 (RPLACD P2RPLAC) (SETARG P2SETARG) (STORE P2STORE))
04300
04400 (SETQ CARCDRDEPTH 4)
04500
04600
00100 (PROG (BASE COUNT LIMIT MIDDLE NAME)
00200 (SETQ BASE 2)
00300 (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
00400 (SETQ COUNT (LSH 1 1))
00500 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
00600 (SETQ MIDDLE (SUBST (QUOTE A)
00700 0
00800 (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
00900 (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
01000 (PUTPROP NAME
01100 (CONS (CAR MIDDLE)
01200 (COND ((CDR MIDDLE)
01300 (READLIST (APPEND (QUOTE (C))
01400 (CDR MIDDLE)
01500 (QUOTE (R)))))))
01600 (QUOTE CARCDR))
01700 (SETQ COUNT (ADD1 COUNT))
01800 (GO LOOP))
01900
02000 (MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
02100 (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))
02200
02300 (MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
02400 (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))
02500
02600 (MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
02700 (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
02800 (MOVE MOVEI))
02900
03000 (SETQ NACS 5)
03100
03200 (SETQ VALUEAC 1)
03300
03400 (SETQ FARGAC 1)
03500
03600 (SETQ GOTABAC 1)
03700
03800 (SETQ ARRAYAC 1)
03900
04000 (SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
04100
04200 (ENDBLOCK PASS2)
04300
04400 (BEGINBLOCK DEBUG)
04500
04600
00100 (DFUNC (CMPBREAK TYPE MESSAGE)
00200 (PROG NIL
00300 (INC NIL T)
00400 (OUTC NIL T)
00500 (COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
00600 (PRINL (APPEND TYPE MESSAGE))
00700 (LINEF 1)
00800 LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
00900 (RETURN (Q DONE))))
01000 (GO LOOP)))
01100
01200 (DEFPROP COMPERR
01300 (LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
01400 FEXPR)
01500
01600 (DFUNC (EVALREAD)
01700 (PROG (EX)
01800 (LINEF 1)
01900 (SETQ EX (READ))
02000 (PRINC *SP)
02100 (RETURN (PRINC (EVAL EX)))))
02200
02300 (DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
02400
02500 (DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
02600
02700 (SETQ TRACELIST NIL)
02800
02900 (ENDBLOCK DEBUG)
03000
03100 (BEGINBLOCK IO)
03200
03300 (DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
03400
03500 (DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
03600
03700 (DFUNC (CURCOL) (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))
03800
03900 (DFUNC (FORMF) (PROGN (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
04000
04100 (DFUNC (LINEF N)
04200 (PROG NIL
04300 LOOP (COND ((ZEROP N) (RETURN NIL)))
04400 (TERPRI)
04500 (SETQ N (SUB1 N))
04600 (GO LOOP)))
04700
04800 (DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
04900
05000
00100 (DFUNC (PRINS FN)
00200 (PROG2 (COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
00300 (PRINTEXPR FN)))
00400
00500 (DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
00600
00700 (DFUNC (PRINTN CHAR NUM)
00800 (PROG (NO)
00900 (SETQ NO 1)
01000 LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
01100 (PRINC CHAR)
01200 (SETQ NO (ADD1 NO))
01300 (GO LOOP)))
01400
01500 (DFUNC (PRINTSTAT STAT)
01600 (PROG2 (COND ((NULL STAT) (CARRETN) (TABTO 10))
01700 ((ATOM STAT) (TABTO 2))
01800 ((EQ (CAR STAT) (Q LAP)) (TABTO 1))
01900 (T (TABTO 10)))
02000 (PRINTEXPR STAT)))
02100
02200 (DFUNC (TABTO COL)
02300 (PROGN (COND ((GREATERP (CURCOL) COL) (LINEF 1)))
02400 (PRINTN *TB
02500 (*DIF (LSH (SUB1 COL) -3) (LSH (SUB1 (CURCOL)) -3)))
02600 (PRINTN *SP (*DIF COL (CURCOL)))))
02700
02800 (MAPCAR (FUNCTION (LAMBDA (PAIR)
02900 (PROG2 (SET (CAR PAIR)
03000 (INTERN (ASCII (CADR PAIR))))
03100 (CAR PAIR))))
03200 (QUOTE ((*SP 40) (*TB 11)
03300 (*CR 15)
03400 (*LF 12)
03500 (*VT 13)
03600 (*FF 14)
03700 (*CO 54)
03800 (*PT 56)
03900 (*LP 50)
04000 (*RP 51)
04100 (*SL 57)
04200 (*AM 33)
04300 (*AT 100)
04400 (*RO 177)
04500 (*COLON 72))))
04600
04700 (SETQ LINCNT 0)
04800
04900 (SETQ PAGEHEIGHT 74)
05000
05100 (SETQ PAGEWIDTH 120)
05200
05300
00100 (ENDBLOCK IO)
00200
00300 (BEGINBLOCK GENERAL)
00400
00500 (DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
00600
00700 (DFUNC (ASSOCR X Y)
00800 (PROG NIL
00900 LOOP (COND ((NULL Y) (RETURN NIL))
01000 ((EQ X (CDAR Y)) (RETURN (CAR Y))))
01100 (SETQ Y (CDR Y))
01200 (GO LOOP)))
01300
01400 (DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (Q (T NIL)))))
01500
01600 (DFUNC (COPY EX) (SUBST 0 0 EX))
01700
01800 (DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))
01900
02000 (DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
02100
02200 (DFUNC (GETGET ATOM PROP)
02300 (PROG (TEM PTAB)
02400 (SETQ PTAB (FIRSTPROP ATOM))
02500 LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
02600 (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
02700 (RETURN TEM)))
02800 (SETQ PTAB (NEXTPROP PTAB))
02900 (GO LOOP)))
03000
03100 (DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
03200
03300 (DFUNC (MAKESPECIAL VAR)
03400 (PROGN (COND ((HASPROP VAR (Q LOCAL))
03500 (PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
03600 (SETPROP VAR (Q SPECIAL) T)
03700 VAR))
03800
03900 (DFUNC (MAKESYM IDENT NUMBER)
04000 (PROG (*NOPOINT)
04100 (SETQ *NOPOINT T)
04200 (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
04300
04400 (DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))
04500
04600
00100 (DEFPROP NEXTSYM
00200 (LAMBDA (NAME)
00300 (PROG (NUM)
00400 (SETQ NUM (GETPROP (CAR NAME) (Q SYMNO)))
00500 (PUTPROP (CAR NAME) (ADD1 NUM) (Q SYMNO))
00600 (RETURN (MAKESYM (CAR NAME) NUM))))
00700 FEXPR)
00800
00900 (DFUNC (NTHCDR NUM EXP)
01000 (PROG NIL
01100 (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
01200 LOOP (COND ((ZEROP NUM) (RETURN EXP)))
01300 (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
01400 (SETQ EXP (CDR EXP))
01500 (SETQ NUM (SUB1 NUM))
01600 (GO LOOP)))
01700
01800 (DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)
01900
02000 (DEFPROP STARTSYM
02100 (LAMBDA (SYMS)
02200 (PROG NIL
02300 LOOP (COND ((NULL SYMS) (RETURN NIL)))
02400 (INITPROP (CAR SYMS) (Q SYMNO) 1)
02500 (SETQ SYMS (CDR SYMS))
02600 (GO LOOP)))
02700 FEXPR)
02800
02900 (DEFPROP STOPSYM
03000 (LAMBDA (SYMS)
03100 (PROG NIL
03200 LOOP (COND ((NULL SYMS) (RETURN NIL)))
03300 (DELETEPROP (CAR SYMS) (Q SYMNO))
03400 (SETQ SYMS (CDR SYMS))
03500 (GO LOOP)))
03600 FEXPR)
03700
03800 (DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
03900
04000 (DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
04100
04200 (ENDBLOCK GENERAL)
04300
04400 (ENDBLOCK COMPILER)
04500